The Programmer Disk

home *** CD-ROM | disk | FTP | other *** search

/ The Programmer Disk / The Programmer Disk (Microforum).iso / xpro / basic1 / pro9 / fed-demo.bas < prev next >

Wrap

BASIC Source File | 1987-07-31 | 19.5 KB | 537 lines

REM $TITLE: 'FED - DEMO' REM $SUBTITLE: 'Text input demo ' REM (C) InfoSoft, 1987 CLEAR DEFINT a-z OPTION BASE 1 'make sure it is set up right CLS : SOUND 750,2 : LOCATE 5,5 PRINT "Depending on your display, you may want to restart this demo" LOCATE 7,5 PRINT "with the command line parameter [/CMD /NC] or [/CMD /C]. /NC for" LOCATE 9,5 PRINT "No Color, /C for color version. This should be noted in F-DEMO.BAT" LOCATE 13,5 PRINT "Tap `S' to stop the demo, any other key to continue." GOSUB wait.key IF ky$="S" OR ky$="s" THEN GOTO ext END IF '*********** get command line parms and set colors DIM arg$(2) : q%=0 FOR x = 1 TO 2 arg$(x)=SPACE$(LEN(COMMAND$)/2) NEXT x CALL cmdline(arg$(),q%) IF arg$(1)="/NC" THEN ' find out if command line wants color fg=7 : bg=0 fge=15 : bge=0 fgw=0 : bgw=7 fgd=15 : bgs=0 fgh=7 : bgh=15 fgb=15 : bgb=0 fgt=7 : bgt=0 ELSE fg=2:bg=0 ' general colors fge=12:bge=3 ' err message colors fgw=14:bgw=4 ' window colors fgd=10:bgs=0 ' data colors fgh=15 : bgh=1 ' help colors fgb=4 : bgb=0 ' box color fgt=3 : bgt=0 ' text colors END IF eattr=(bge*16)+fge ' error message attributes wattr=(bgw*16)+fgw ' window attributes hattr=(bgh * 16 ) + fgh ' help window attributes DIM sarry(4000) 'dimension screen array for 2 screens sptr1%=VARPTR(sarry(1)) ' points to first screen position sptr2%=VARPTR(sarry(2001)) ' points to second screen position DIM hlp$(10) ' String array to hold help screen msgs for use later. ' Has to be DIMmed in code prior to other references ' to hlp$(). hlp$(1)="Home - Start of line End - End of line" hlp$(2)=" " hlp$(3)="Ctrl-X Clear Field Ctrl-End Clear to end of line" hlp$(4)="Ctrl-U Undo <Arrows> Fwd, Bkwd 1 field " hlp$(5)=" " hlp$(6)=" PgUp / Ctrl PgUp - Jump to first field " hlp$(7)=" PgDn / Ctrl PgDn - Jump to last field " hlp$(8)=" " hlp$(9)="[Esc] or [F9] Aborts Current Edit [F10] Save Record" hlp$(10)="[ Tap any key to continue ]" prg.start: '*************** start of program ***************** GOSUB gen.disp ' put screen mask on screen CALL svscrn(sptr1%) ' save it - RSTSCRN is quicker next time GOSUB openfil ' open the file IF hi=0 THEN GOSUB newfil rec.no = hi ' get the top rec no GOSUB rec.disp ' display given record '***************************************************************************** '* Each label below the sets up the flags and variables for editing for one * '* of the fields in the database or on the screen. A MAJOR part of the * '* Field EDitor (FED), is in the subroutine called CHGFLD, which routes the * '* flow of the code to the appropriate points. The random access file * '* contained here is pretty minimal - just enough to be able to demo FED. * '* In a "real" random file application, there are a number of things that * '* should be done in the way of checking for valid data, also, there are * '* functions missing like to delete a record (missing because it does not * '* lend itself to demoing FED or GIZLIB). There ARE several other GIZLIB * '* functions used: ERRMSG, DLRFRMAT, NFRMAT, WDW and a few others. * '***************************************************************************** ed.n: '----- edit name ------ LOCATE 4,10 ' FED parameters ucase=1 : nums=0 : bleep=1 ' turn caps only ON, nums only OFF, fsiz=25 ' error sound ON, set size of string CALL fed(mn$, fsiz%, fcode%) '--- handles part of the return from FED ---------- IF fcode = 5 THEN ' if up arrow, go up one GOTO ed.n ELSEIF fcode <> 6 OR fcode <> 0 THEN ' if NOT down or enter GOSUB chgfld ' see where they want to go END IF ' if down or enter pressed, just advance one field ed.p: ' ----- edit phone number --------- LOCATE 4,57 ucase=0 : nums=1 : num$="1234567890-" : bleep=0 fsiz=8 : temp$=mp$ ' save a copy of phone in case of error CALL fed(temp$, fsiz%, fcode%) m=2 : p=0 ' m sets NFRMAT mode, p is useless CALL nfrmat(temp$, m, p) IF m=2 THEN ' if format went okay mp$=temp$ ' assign value to memory var ELSE ' something went wrong !! CALL errmsg(temp$, 23, eattr%, 2) ' tell them of error GOTO ed.p ' note that we do not know what the END IF ' error is! Just that there is one IF fcode=5 THEN ' up arrow... GOTO ed.n ' ...back up one field ELSEIF fcode <> 6 OR fcode <> 0 THEN ' if NOT down or enter GOSUB chgfld ' see where they want to go END IF ed.a: '----- edit address ----- LOCATE 6,13 nums=0 : ucase=0 : fsiz=25 : bleep=1 ' nums only OFF, caps OFF, bleepr ON CALL fed(ma$, fsiz%, fcode%) IF fcode=5 THEN ' up arrow GOTO ed.p ELSEIF fcode <> 6 OR fcode <> 0 THEN ' if NOT down or enter GOSUB chgfld ' see where they want to go END IF ed.c: ' ----- edit city ----- LOCATE 8,10 ucase=1 : nums=0 : fsiz=10 : bleep=1 ' caps ON, nums only OFF, sound ON CALL fed(mc$, fsiz%, fcode%) IF fcode=5 THEN ' up arrow GOTO ed.a ELSEIF fcode <> 6 OR fcode <> 0 THEN ' if NOT down or enter GOSUB chgfld ' see where they want to go END IF ed.s: ' ----- edit state ----- LOCATE 8,42 fsiz=2 : bleep=0 ' turn sound ON, set size CALL fed(ms$, fsiz%, fcode%) IF fcode=5 THEN ' up arrow GOTO ed.c ELSEIF fcode <> 6 OR fcode <> 0 THEN ' if NOT down or enter GOSUB chgfld ' see where they want to go END IF ed.z: '----- edit zip code ----- LOCATE 8,60 nums=1 : num$="1234567890" ' turn nums only ON, bleepr OFF fsiz=5 : bleep=0 CALL fed(mz$, fsiz%, fcode%) IF fcode=5 THEN ' up arrow GOTO ed.s ELSEIF fcode <> 6 OR fcode <> 0 THEN ' if NOT down or enter GOSUB chgfld ' see where they want to go END IF ed.d: '----- edit department ----- LOCATE 12,16 ucase=1 : nums=0 ' caps ON, nums only OFF, bleepr ON fsiz=6 : bleep=1 CALL fed(md$, fsiz%, fcode%) IF fcode=5 THEN ' up arrow GOTO ed.z ELSEIF fcode <> 6 OR fcode <> 0 THEN ' if NOT down or enter GOSUB chgfld ' see where they want to go END IF ed.sv: '----- edit supervisor name ----- LOCATE 12,57 fsiz=12 ' same bleepr, caps and nums state CALL fed(msv$, fsiz%, fcode%) IF fcode=5 THEN ' up arrow GOTO ed.d ELSEIF fcode <> 6 OR fcode <> 0 THEN ' if NOT down or enter GOSUB chgfld ' see where they want to go END IF ed.pf: '----- edit pay freq ----- LOCATE 14,41 fsiz=1 ' same caps etc settings temp$=mfreq$ ' save a copy cause they can screw it up CALL fed(temp$, fsiz%, fcode%) IF INSTR("HS",temp$)=0 THEN CALL errmsg("Pay Frequency code must be H or S only.", 24, eattr%, 2) GOTO ed.pf END IF mfreq$=temp$ ' assign correct one IF fcode=5 THEN ' up arrow GOTO ed.sv ELSEIF fcode <> 6 OR fcode <> 0 THEN ' if NOT down or enter GOSUB chgfld ' see where they want to go END IF ed.r: '----- edit pay rate ----- LOCATE 14,70 nums=1 : num$="1234567890.$" 'turn nums only on, turn OFF bleepr bleep=0 : fsiz=6 : temp$=mrat$ CALL fed(temp$, fsiz%, fcode%) m=0 : p=2 ' set up for dollar formatting call CALL dlrfrmat(temp$, m%, p%) IF m<>0 THEN ' if m is changed CALL errmsg(temp$, 24, eattr, 2) ' GOTO ed.r END IF mrat$=temp$ IF fcode=5 THEN ' up arrow GOTO ed.pf ELSEIF fcode <> 6 OR fcode <> 0 THEN ' if NOT down or enter GOSUB chgfld ' see where they want to go END IF ed.pin: '----- edit PIN code ----- LOCATE 16,17 : PRINT mpin$ ' it is previuosly hidden nums=1 : num$="1234567890" bleep=0 : fsiz=4 ' bleep is same as last one, but LOCATE 16,17 ' they can JUMP here via PgDn CALL fed(mpin$, fsiz%, fcode%) LOCATE 16,17 : PRINT STRING$(4,254) ' re hide their code IF fcode=5 THEN ' up arrow GOTO ed.r ELSEIF fcode <> 6 OR fcode <> 0 THEN ' if NOT down or enter GOSUB chgfld ' see where they want to go END IF savrec: ' save a record GOSUB closefil ' LSET and close the file edt=0 ' reset the edit flag GOSUB show.rec ' show the new version GOTO ed.n ' go to first field ext: SYSTEM '================================[ SUBROUTINES ]============================== '****************************************************************************** '* In the way that FED is implemented here, most all of the FED Exit codes * '* (aka FCODE), can be handled in a gosub to something like the following. * '* Regardless of what field they are editting, F9, F10, F1, PgUp, PgDn etc * '* all mean the same thing: abort, save, help, Jump to start, jump to end etc * '* The only FCODE that cannot be handled here (given the way that I have * '* this implementation set up) is and Up Arrow (fcode=5). ENTER, and Dn Arrow* '* (fcodes 0 and 6) are not handled here or at all actually, they "fall thru" * '* to the next label rather than being routed here. * '* Some sort of routine like this is essential to FED's operation. * '****************************************************************************** chgfld: IF edt THEN ' This part is not critical, COLOR bgb, fgb ' but shows user when current LOCATE 1, 35 ' record is different from data PRINT " [ EDITING ] " ' in file. ELSE COLOR fgb, bgb LOCATE 1, 38 PRINT STRING$(15, 205); ' overwrite EDITING flag END IF COLOR fg,bg SELECT CASE fcode ' CASE is new to QB 3.0 - will not compile in 2.x CASE 1 ' F1 key pressed (HELP) CALL svscrn(sptr2%) ' save screen as is CALL wdw(7, 12, 17, 72, 1, 1, 2, hattr,"Editing Help") FOR x=1 TO 9 ' pop help window up CALL quikprt(hlp$(x), 7+x, 14, hattr%) NEXT x ' QUIKPRT help msgs LOCATE 18, 30 : COLOR fgh, bgh : PRINT hlp$(10) GOSUB wait.key ' wait for any key CALL rstscrn(sptr2%) ' restore pre help screen RETURN ' RETURN to next label CASE 3 ' F3 page back a record IF edt THEN ' they have changed something CALL errmsg("You cannot PAGE until current edit is saved.", 24, eattr%, 2) RETURN END IF IF rec.no > 1 THEN rec.no=rec.no-1 ' back up a record CALL rstscrn(sptr1%) ' restore blank screen (bleed thru) GOSUB rec.disp ' display desired record RETURN ed.n ' goto first field CASE 4 ' F4 page forward a record IF edt THEN ' they have changed something CALL errmsg("You cannot PAGE until current edit is saved.", 24, eattr%, 2) RETURN END IF IF rec.no < hi THEN rec.no=rec.no+1 ' forward a record CALL rstscrn(sptr1%) GOSUB rec.disp ' display desired record RETURN ed.n ' goto first field CASE 7 ' F7 add a record IF edt then CALL errmsg("Cannot ADD until current EDIT is saved.", 24, eattr, 2) ELSE rec.no=hi+1 ' increment record pointer ' ---- set all mem vars to nul strings ----- mn$="" : mp$="" : ma$="" : mc$="" : ms$="" mz$="" : md$="" : msv$="" : mfreq$="" mrat$="" : mpin$=STRING$(4,254) CALL rstscrn(sptr1%) GOSUB show.rec ' display RETURN ed.n END IF CASE 9, 15 ' F9, ESC rec.no=1 ' this should have a "ARE YOU SURE" GOSUB rec.disp ' prompt if it was more than demo RETURN ed.n ' redisplay current record CASE 10 ' F10 save record RETURN savrec CASE 11, 13 'Pg Up or ^Pg Up RETURN ed.n CASE 12, 14 'Pg Dn or ^Pg Dn RETURN ed.pin CASE ELSE ' handles all other fed codes RETURN ' (F2, F8 - advance a field) END SELECT openfil: '----------- open demo file and FIELD statements --------- OPEN "emp.dat" AS #1 LEN=104 FIELD #1, 25 AS n$, 8 AS p$, 25 AS a$, 10 AS c$, 2 AS s$, 5 AS z$, _ 6 AS d$, 12 AS sv$, 1 AS freq$, 6 AS rat$, 4 AS pin$ sof=LOF(1)/104 ' sof is number of records in file hi=sof ' hi is high record number RETURN closefil: '------------- LSET and store the record --------------- LSET n$=mn$ : LSET p$=mp$ : LSET a$=ma$ : LSET c$=mc$ : LSET s$=ms$ LSET z$=mz$ : LSET d$=md$ : LSET sv$=msv$ : LSET freq$=mfreq$ LSET rat$=mrat$ : LSET pin$=mpin$ PUT #1, rec.no ' move record to buffer CLOSE #1 ' actually put file to disk GOSUB openfil ' open file again in updated state RETURN rec.disp: '---------- put selected record to the screen ----------- ' convert to memory variable to edit a COPY ' of each and strip trailing blanks GET #1, rec.no mn$=n$ : CALL stripr(mn$) : mp$=p$ : CALL stripr(mp$) ma$=a$ : CALL stripr(ma$) : mc$=c$ : CALL stripr(mc$) ms$=s$ : CALL stripr(ms$) : mz$=z$ : CALL stripr(mz$) md$=d$ : CALL stripr(md$) : msv$=sv$ : CALL stripr(msv$) mfreq$=freq$ : CALL stripr(mfreq$) : mrat$=rat$ : CALL stripr(mrat$) mpin$=pin$ : CALL stripr(mpin$) show.rec: ' display the record IF edt THEN ' This part is not critical, COLOR bgb, fgb ' but shows user when current LOCATE 1, 35 ' record is different from data PRINT " [ EDITING ] " ' in file. ELSE COLOR fgb, bgb LOCATE 1, 35 PRINT STRING$(15, 205); END IF COLOR fg,bg COLOR fg,bg LOCATE 4,10 : PRINT mn$ LOCATE 4,57 : PRINT mp$ LOCATE 6,13 : PRINT ma$ LOCATE 8,10 : PRINT mc$ LOCATE 8,42 : PRINT ms$ LOCATE 8,60 : PRINT mz$ LOCATE 12,16 : PRINT md$ LOCATE 12,57 : PRINT msv$ LOCATE 14,41 : PRINT mfreq$ LOCATE 14,70 : PRINT mrat$ LOCATE 16,17 : PRINT STRING$(4,254) LOCATE 16,71 : COLOR fgw,0 : PRINT rec.no% COLOR fg,bg edt=0 ' set edit flag to show that record on screen is same as file RETURN gen.disp: '***************************************************************************** '* Routine to put general display on the screen, this is used once. After * '* it is put to the screen, it is saved via SVSCRN, and restored from there * '* rather than doing all these PRINTs again. * '***************************************************************************** CALL boxes(5,1,fgb) 'put a big box on screen COLOR fgt+8 LOCATE 2,25 : PRINT "XYZ Corporation Employee Data File" ' a title COLOR fgt LOCATE 4,4 : PRINT "Name: " LOCATE 4,50 : PRINT "Phone: " LOCATE 6,4 : PRINT "Address: " LOCATE 8,4 : PRINT "City: " LOCATE 8,35 : PRINT "State: " LOCATE 8,55 : PRINT "Zip: " LOCATE 12,4 : PRINT "Department: " LOCATE 12,45 : PRINT "Supervisor: " LOCATE 14,4 : PRINT "Hourly / Salary Level (H or S only): " LOCATE 14,60 : PRINT "Pay Rate: " LOCATE 16, 55 : PRINT "Record Number: "; LOCATE 16,4 : PRINT "4 Digit PIN: " COLOR 4,0 : LOCATE 17,1 : PRINT CHR$(199)+STRING$(78,196)+CHR$(182) COLOR fgt+8 : LOCATE 18,30 : PRINT "Editing Keys:": COLOR fgt LOCATE 20,5 : PRINT "[F1] - Help [F7] Add Record [F9] - Abort Edit [F10] - Save" LOCATE 21,10 : PRINT "[F3] - Page back one record [F4] - Page forward one record" LOCATE 22,10 : PRINT "[Enter] - Advances a field. [PgDn] - Jump to last field" LOCATE 23,5 : PRINT "[PgUp] - Jump to first field <Arrow Keys> Advance or back up one field." RETURN newfil: '---------------- make a new file if demo one got lost ------- mn$="JIM LOTUS" mp$="555-0123" ma$="1432 OAK STREET" mc$="CENTERVILE" ms$="MA" mz$="01234" md$="EXEC." msv$="NONE" mfreq$="S" mrat$="900.00" mpin$="1234" rec.no=1 GOSUB closefil RETURN wait.key: '--------loop until a key is pressed - handy to have ky$="" DO UNTIL ky$<>"" ky$=INKEY$ LOOP RETURN '***************************************************************************** '* Here is how & where we include the external FED file into our code. * '* Earlier QB versions had problems with SHARED variables passed to INCLUDE * '* files unless the included file was put towards the end of the code. Out * '* of habit (and fear) I still $INCLUDE them late in the code. * '***************************************************************************** REM $INCLUDE: 'FED.BAS'